Internet Pratica/IPRAT_01.iso/ASP/ASPapp Portal/i_utils.asp

Text File | 2002-03-12 | 14KB | 441 lines

<%

'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
':::::: i_utils.asp global function library for aspapp.com  :::::::::
':::::: copyright 1999-2001 Iatek,LLC. All rights reserved.  ::::::::
'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::


'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
''  GLOBAL DECLARATIONS AND DATABASE CONNECTIONS
'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

''' initiate global vars and constants
dim action
dim b_error, a_errors, error_list, a_msg, msg_list
dim cn, cmd, rs, rsselect, sql, do_search, a_records

''' instantiate error handling and messaging
set error_list = CreateObject("Scripting.Dictionary")
set msg_list = CreateObject("Scripting.Dictionary")

''' initiate db objects and connections

''''' app database
set cn = Server.CreateObject("ADODB.Connection")
cn.Open "provider=microsoft.jet.oledb.4.0;data source=" & server.MapPath("data\7045.mdb") & ""

''''' user database (may be the same as app)
set user_cn = Server.CreateObject("ADODB.Connection")
user_cn.Open "provider=microsoft.jet.oledb.4.0;data source=" & server.MapPath("data\7045.mdb") & ""

''''' command object
set cmd = Server.CreateObject("ADODB.Command")
cmd.ActiveConnection = cn

''''' recordset object
set rs = Server.CreateObject("ADODB.Recordset")




'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
''  ERROR AND MESSAGE DISPLAY SUBS
'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

sub display_errs
':::::::::::::::::::::::::::::::::::::::::::::::::::::
    ' display content of the error dictionary object
':::::::::::::::::::::::::::::::::::::::::::::::::::::
if error_list.count > 0 then
    ''' display errors
    response.write "<div>"
    a_errors = error_list.items
    for i = 0 to error_list.count - 1
    response.write "<li class=ErrFont>" & a_errors(i) & "</li>"
    response.write "</div>"
    next
end if
end sub

sub display_msg
':::::::::::::::::::::::::::::::::::::::::::::::::::::
' displays msgs after successful database action
':::::::::::::::::::::::::::::::::::::::::::::::::::::
    ':: check if a msg was passed to the page
    if request("msg") <> "" then msg_list.add "msg", request("msg")
    ':: display messages
    a_msg = msg_list.items
    for i = 0 to msg_list.count - 1
        response.write "<div class=MsgFont>" & a_msg(i) & "</div>"
    next
end sub



'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
''  USER MANAGMENT FUNCTIONS
'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

function check_security(iLevel)
':::::::::::::::::::::::::::::::::::::::::::::::::::::
' authenticates user and verifies access level
':::::::::::::::::::::::::::::::::::::::::::::::::::::
    if session("user_id") = "" OR isNull(session("accesslevel")) then
        response.redirect("login.asp?querystring=" & to_url(request.serverVariables("QUERY_STRING")) & "&ret_page=" & to_url(request.serverVariables("SCRIPT_NAME")))
    elseif session("accesslevel") <> "" then
        if cLng(session("accesslevel")) < cLng(iLevel) then response.redirect("login.asp?msg=You+do+not+have+permission+to+access+the+requested+page.&querystring=" & to_url(request.serverVariables("QUERY_STRING")) & "&ret_page=" & to_url(request.serverVariables("SCRIPT_NAME")))
    else
        user_id = session("user_id")
        accesslevel = session("accesslevel")
    end if
end function

sub do_login
':::::::::::::::::::::::::::::::::::::::::::::::::::::
' autheticates user in db and creates session
':::::::::::::::::::::::::::::::::::::::::::::::::::::
    user_name = request("user_name")
       password = request("password")

    sql = "SELECT user_name, password FROM Users WHERE user_name = " & to_sql(user_name,"text") & " AND password = " & to_sql(password,"text") & ""
    set rs = user_cn.Execute(sql)
    if rs.EOF then
        'login failed
        error_list.add "login", "Login or password in incorrect."
        b_error = true
    else
        'login and password passed
        sql = "SELECT user_id, accesslevel FROM Users WHERE user_name = " & to_sql(user_name,"text") & " AND password = " & to_sql(password,"text") & ""
        set rs = user_cn.Execute(sql)

        if rs.EOF then
            'should never happen
            error_list.add "login", "User does not exist."
            b_error = true
        else
            'login user
            session("user_id") = rs(0)
            session("accesslevel") = rs(1)
            'where to next?
            querystring = request("querystring")
            ret_page = request("ret_page")
            if (ret_page <> request.serverVariables("SCRIPT_NAME")) AND (ret_page <> "") then
                'return to page that preceded login
                response.redirect(ret_page & "?" & querystring)
            else
                'go home
                response.redirect("default.asp")
            end if
        end if
    end if
    rs.Close

end sub



'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
''  FORMATTING FUNCTIONS
'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

function to_url(strValue)
':::::::::::::::::::::::::::::::::::::::::::::::::::::
' make passed paramters url friendly
':::::::::::::::::::::::::::::::::::::::::::::::::::::
    if IsNull(strValue) then strValue = ""
    to_url = Server.URLEncode(strValue)
end function

function to_html(strValue)
':::::::::::::::::::::::::::::::::::::::::::::::::::::
' convert string to html
':::::::::::::::::::::::::::::::::::::::::::::::::::::
    if IsNull(strValue) then strValue = ""
    to_html = Server.HTMLEncode(strValue)
end function

function to_sql(Value,DataType)
    if Value = "" or isNull(Value) then
        to_sql = "NULL"
    elseif DataType <> "number" then
        to_sql = "'" & Replace(Value, "'", "''") & "'"
    else
        to_sql = Value
    end if
end function

function get_options(sql,selected_value)
':::::::::::::::::::::::::::::::::::::::::::::::::::::
' displays option tags for a select list
':::::::::::::::::::::::::::::::::::::::::::::::::::::
    'response.write sql
    if isNull(selected_value) then selected_value = ""
    set rsSelect = cn.Execute(sql)
    do until rsSelect.EOF
        if not isNull(rsSelect(0)) then
            get_options = get_options + "<option"
            if cStr(rsSelect(0)) = cStr(selected_value) then
                get_options = get_options + " SELECTED"
            end if
            get_options = get_options + " value='" & rsSelect(0) & "'>"
            if rsSelect.Fields.Count-1 = 0 then
                get_options = get_options + "" & rsSelect(0) & " "
            else
                for i = 1 to rsSelect.Fields.Count-1
                    if rsSelect(i) <> "" then
                        get_options = get_options + "" & rsSelect(i)
                        if i < rsSelect.Fields.Count-1 then get_options = get_options + ": "
                    end if
                next
            end if
            get_options = get_options + "</option>" & vbCRLF & chr(9) & chr(9)
        end if
    rsSelect.MoveNext
    loop
    rsSelect.Close
end function

function is_reserved(strValue)
':::::::::::::::::::::::::::::::::::::::::::::::::::::
' compare a string with a list of vb and sql reserved words
':::::::::::::::::::::::::::::::::::::::::::::::::::::
    reserved_words = "|and||as||boolean||byref||byte||byval||call||case||class||const||currency||date||desc||debug||dim||do||double||each||else||elseif||empty||end||endif||enum||eqv||event||exit||false||for||function||get||goto||if||imp||implements||in||integer||is||let||like||long||loop||lset||me||mod||new||next||not||nothing||null||on||option||optional||or||paramarray||preserve||private||public||raiseevent||redim||rem||resume||rows||rset||select||set||shared||single||size||static||stop||sub||then||to||true||type||typeof||until||variant||wend||while||with||xor|"
    if inStr(reserved_words,"|" & lcase(strValue) & "|") > 0 then
        is_reserved = true
    else
        is_reserved = false
    end if
end function



'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
''  GENERIC DATABASE SUBS -- These are handy, but not optimal for db reads and writes
'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

function db_select(tablename,keyfield,keyvalue)
':::::::::::::::::::::::::::::::::::::::::::::::::::::
' selects a key record from db and stores fieldnames
' and values in the global a_records array (first element).
' The function will return 1 if values are found, otherwise 0.
':::::::::::::::::::::::::::::::::::::::::::::::::::::

    dim rsT
    dim rsSQL

    rsSQL = "SELECT * FROM " & tablename & " WHERE " & keyfield & " = " & keyvalue
    set rsT = cn.Execute(rsSQL)

    if not rsT.EOF then
        db_select = 1
        redim a_records(1,rsT.Fields.Count-1,1)
        for i = 0 to (rsT.Fields.Count-1)
            a_records(1,i,0) = rsT(i).name
            a_records(1,i,1) = rsT(i)
        next
    else
        db_select = 0
    end if

    rsT.close
    set rsT = NOTHING

end function

function db_insert(tablename,keyfield)
':::::::::::::::::::::::::::::::::::::::::::::::::::::
' examines name and values in the .asp request object and
' creates an insert statement corresponding to the names
' and values found in the request object. Attemps to insert
' the record into tablename. The function will
' return the value of the keyfield for the newly inserted
' record, otherwise 0.
':::::::::::::::::::::::::::::::::::::::::::::::::::::

    dim rsT
    dim rsSQL

    rsSQL = "SELECT TOP 1 * FROM " & tablename
    set rsT = cn.Execute(rsSQL)

    if not rsT.EOF then
        rsSQL = "INSERT INTO " & tablename
        rsSQL = rsSQL + "("

        for i = 0 to (rsT.Fields.Count-1)
            if (request(rsT(i).name) <> "") AND rsT(i).name <> keyfield then
                rsSQL = rsSQL + "" & rsT(i).name & ""
                if i <> rsT.Fields.Count-1 then rsSQL = rsSQL + ","
            end if
        next

        ''' truncate last comma
        rsSQL = left(rsSQL,len(rsSQL)-1)

        rsSQL = rsSQL + ") VALUES ("

        for i = 0 to (rsT.Fields.Count-1)
            if (request(rsT(i).name) <> "") AND rsT(i).name <> keyfield then
                value = request(rsT(i).name)
                ''' determine datatype
                ''' for more info http://www.aspdeveloper.net/iasdocs/aspdocs/ref/comp/daprop06_4.htm
                select case rsT(i).type
                case 129,7,133,134,135,205,201,203,204,200,128
                    rsSQL = rsSQL + "" & to_sql(value,"text") & ","
                case else
                    rsSQL = rsSQL + "" & to_sql(value,"number") & ","
                end select
            end if
        next

        ''' truncate last comma
        rsSQL = left(rsSQL,len(rsSQL)-1)

        rsSQL = rsSQL + ")"
        response.write rsSQL
        'on error resume next
        cn.Execute(rsSQL)
        if err.Number <> 0 then
            b_error = true
            error_list.add "db_insert_" & err.Number ,"The insert failed: " & tablename & "." & err.Description
            db_insert = 0
        else
            set rsT = cn.Execute("SELECT @@IDENTITY")
            db_insert = rsT(0)
        end if
        on error goto 0

    else
        db_insert = 0
    end if

    rsT.close
    set rsT = NOTHING

end function

function db_update(tablename,keyfield)
':::::::::::::::::::::::::::::::::::::::::::::::::::::
' examines name and values in the .asp request object and
' creates an update statement corresponding to the names
' and values found in the request object. Attemps to
' update the record in tablename. If successful, the
' function will the return the value of 1, otherwise 0.
' The value of the keyfield also must be contained in the
' request object.
':::::::::::::::::::::::::::::::::::::::::::::::::::::

    dim rsT
    dim rsSQL

    rsSQL = "SELECT TOP 1 * FROM " & tablename
    set rsT = cn.Execute(rsSQL)

    if not rsT.EOF and request(keyfield) <> "" then
        rsSQL = "UPDATE " & tablename
        rsSQL = rsSQL + " SET "

        for i = 0 to (rsT.Fields.Count-1)
            if (request(rsT(i).name) <> "") AND rsT(i).name <> keyfield then
                name = rsT(i).name
                value = request(rsT(i).name)
                ''' determine datatype
                ''' for more info http://www.aspdeveloper.net/iasdocs/aspdocs/ref/comp/daprop06_4.htm
                select case rsT(i).type
                case 129,7,133,134,135,205,201,203,204,200,128
                    rsSQL = rsSQL + "" & name & " = " & to_sql(value,"text") & ","
                case else
                    rsSQL = rsSQL + "" & name & " = " & to_sql(value,"number") & ","
                end select
            end if
        next

        ''' truncate last comma
        rsSQL = left(rsSQL,len(rsSQL)-1)

        rsSQL = rsSQL + " WHERE " & keyfield & " = " & request(keyfield)

        'response.write rsSQL
        on error resume next
        cn.Execute(rsSQL)
        if err.Number <> 0 then
            b_error = true
            error_list.add "db_update_" & err.Number ,"The update failed: " & tablename & "." & err.Description
            db_update = 0
        else
            db_update = 1
        end if
        on error goto 0

    else
        db_update = 0
    end if

    rsT.close
    set rsT = NOTHING

end function

function db_query(sql)
':::::::::::::::::::::::::::::::::::::::::::::::::::::
' selects record(s) from db and stores fieldnames
' and values in the global a_records array. The function
' will return 1 if values are found, otherwise 0.
':::::::::::::::::::::::::::::::::::::::::::::::::::::

    cmd.CommandText = sql
    set rsT = Server.CreateObject("ADODB.Recordset")
    rsT.CursorLocation = 3
    rsT.Open cmd

    if not rsT.EOF then
        db_query = 1
        num_records = rsT.RecordCount
        redim a_records(num_records-1,rsT.Fields.Count-1,1)
        do until rsT.EOF
            for j = 0 to (rsT.Fields.Count-1)
                a_records(i,j,0) = rsT(j).name
                a_records(i,j,1) = rsT(j)
            next
        rsT.MoveNext
        i = i + 1
        loop
    else
        db_query = 0
    end if

    rsT.close
    set rsT = NOTHING

end function



'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
''  TREE FORM FUNCTIONS
'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

sub clearTree
':::::::::::::::::::::::::::::::::::::::::::::::::::::
' clears array used to construct tree forms
':::::::::::::::::::::::::::::::::::::::::::::::::::::
    redim aTree(0)
    aTree(0) = ""
end sub

sub addItem(sCurrTree, sCurrTreeIMAGE, sTitle, sAnchor, sTarget)
':::::::::::::::::::::::::::::::::::::::::::::::::::::
' adds an item to the tree array
':::::::::::::::::::::::::::::::::::::::::::::::::::::
    dim BRK
    BRK = "||"

    aTree(uBound(aTree)) = sCurrTree & BRK & sCurrTreeIMAGE & BRK & sTitle & BRK & sAnchor & BRK & sTarget

    redim preserve aTree(uBound(aTree) + 1)

end sub

%>